home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / user1.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-06-15  |  29.1 KB  |  777 lines
  1. ;;;; User-Interface, Teil 1
  2. ;;;; Eval-Env, Debugger, Stepper, Errors, Query-User
  3. ;;;; Bruno Haible 4.2.1990, 4.11.1991
  4.  
  5. (in-package "LISP")
  6. (export '(eval-env with-keyboard *keyboard-input*))
  7. (in-package "SYSTEM")
  8.  
  9. ;-------------------------------------------------------------------------------
  10. ;;                                 EVAL-ENV
  11.  
  12. ; Das Toplevel-Environment
  13. (defparameter *toplevel-environment* (eval '(the-environment)))
  14. (defparameter *toplevel-denv* (svref *toplevel-environment* 4))
  15.  
  16. ; Evaluiert eine Form in einem Environment
  17. (defun eval-env (form &optional (env *toplevel-environment*))
  18.   (evalhook form nil nil env)
  19. )
  20.  
  21. ;-------------------------------------------------------------------------------
  22. ;;                                 Debugger
  23.  
  24. (defvar *break-count* 0) ; Anzahl der aktiven Break-Schleifen (Fixnum >=0)
  25.  
  26. ; ZΣhler zum Vermeiden von Endlosrekursionen wegen *error-output*
  27. (defvar *recurse-count-error-output* 0)
  28.  
  29. ; Hauptschleife:
  30. ; (driver
  31. ;   #'(lambda () (read-eval-print "> "))
  32. ; )
  33.  
  34. (defvar *prompt-with-package* nil)
  35. (defun prompt-string-package ()
  36.   (if (and (packagep *package*) (package-name *package*))
  37.     (if (or *prompt-with-package*
  38.             (not (find-symbol "T" *package*)) ; Ist *package* eine Package ohne Lisp-Syntax?
  39.         )
  40.       (string-concat "[" (package-name *package*) "]")
  41.       ""
  42.     )
  43.     (DEUTSCH "[*package* ungⁿltig]"
  44.      ENGLISH "[*package* invalid]"
  45.      FRANCAIS "[*package* invalide]")
  46. ) )
  47. ; Vom Prompt der erste Teil:
  48. (defun prompt-string1 () "")
  49. ; Vom Prompt der zweite Teil:
  50. (defun prompt-string2 () (prompt-string-package))
  51. ; Vom Prompt der letzte Teil:
  52. (defun prompt-string3 () "> ")
  53.  
  54. ; Help-Funktion:
  55. (defvar *key-bindings* nil) ; Liste von Tasten-Bindungen und Helpstrings
  56. (defun help ()
  57.   (dolist (s (reverse (remove-if-not #'stringp *key-bindings*)))
  58.     (write-string s #|*debug-io*|#)
  59. ) )
  60.  
  61. ; Bausteine der Break-Schleife:
  62. (defvar *debug-frame*)
  63. (defvar *debug-mode*)
  64. (defvar *frame-limit1* nil) ; untere Grenze fⁿr frame-down und frame-down-1
  65. (defvar *frame-limit2* nil) ; obere Grenze fⁿr frame-up und frame-up-1
  66. (defun frame-limit1 (frames-to-skip)
  67.   (let ((frame (the-frame)))
  68.     (let ((*frame-limit1* nil)
  69.           (*frame-limit2* nil))
  70.       (dotimes (i frames-to-skip) (setq frame (frame-up-1 frame 1)))
  71.     )
  72.     frame
  73. ) )
  74. (defun frame-limit2 ()
  75.   (let ((frame (the-frame)))
  76.     (let ((*frame-limit1* nil)
  77.           (*frame-limit2* nil))
  78.       (loop
  79.         (let ((nextframe (frame-up-1 frame 1)))
  80.           (when (or (eq nextframe frame) (driver-frame-p nextframe)) (return))
  81.           (setq frame nextframe)
  82.       ) )
  83.       (dotimes (i 2) (setq frame (frame-down-1 frame 1)))
  84.     )
  85.     frame
  86. ) )
  87. (defun debug-help () (help) (throw 'debug 'continue))
  88. (defun debug-unwind () (throw 'debug 'unwind))
  89. (defun debug-mode-1 () (setq *debug-mode* 1) (throw 'debug 'continue))
  90. (defun debug-mode-2 () (setq *debug-mode* 2) (throw 'debug 'continue))
  91. (defun debug-mode-3 () (setq *debug-mode* 3) (throw 'debug 'continue))
  92. (defun debug-mode-4 () (setq *debug-mode* 4) (throw 'debug 'continue))
  93. (defun debug-mode-5 () (setq *debug-mode* 5) (throw 'debug 'continue))
  94. (defun debug-where ()
  95.   (describe-frame *standard-output* *debug-frame*)
  96.   (throw 'debug 'continue)
  97. )
  98. (defun debug-up ()
  99.   (describe-frame *standard-output*
  100.     (setq *debug-frame* (frame-up-1 *debug-frame* *debug-mode*))
  101.   )
  102.   (throw 'debug 'continue)
  103. )
  104. (defun debug-top ()
  105.   (describe-frame *standard-output*
  106.     (setq *debug-frame* (frame-up *debug-frame* *debug-mode*))
  107.   )
  108.   (throw 'debug 'continue)
  109. )
  110. (defun debug-down ()
  111.   (describe-frame *standard-output*
  112.     (setq *debug-frame* (frame-down-1 *debug-frame* *debug-mode*))
  113.   )
  114.   (throw 'debug 'continue)
  115. )
  116. (defun debug-bottom ()
  117.   (describe-frame *standard-output*
  118.     (setq *debug-frame* (frame-down *debug-frame* *debug-mode*))
  119.   )
  120.   (throw 'debug 'continue)
  121. )
  122. (defun debug-backtrace (&optional (mode *debug-mode*))
  123.   (let ((frame (frame-down-1 (frame-up-1 *frame-limit1* mode) mode)))
  124.     (loop
  125.       (describe-frame *standard-output* frame)
  126.       (when (eq frame (setq frame (frame-up-1 frame mode))) (return))
  127.   ) )
  128.   (throw 'debug 'continue)
  129. )
  130. (defun debug-backtrace-1 () (debug-backtrace 1))
  131. (defun debug-backtrace-2 () (debug-backtrace 2))
  132. (defun debug-backtrace-3 () (debug-backtrace 3))
  133. (defun debug-backtrace-4 () (debug-backtrace 4))
  134. (defun debug-backtrace-5 () (debug-backtrace 5))
  135. (defun debug-trap-on ()
  136.   (trap-eval-frame *debug-frame* t)
  137.   (throw 'debug 'continue)
  138. )
  139. (defun debug-trap-off ()
  140.   (trap-eval-frame *debug-frame* nil)
  141.   (throw 'debug 'continue)
  142. )
  143. (defun debug-redo ()
  144.   (redo-eval-frame *debug-frame*)
  145.   (throw 'debug 'continue)
  146. )
  147. (defun debug-return ()
  148.   (return-from-eval-frame *debug-frame*
  149.     (read-form (DEUTSCH "Werte: "
  150.                 ENGLISH "values: "
  151.                 FRANCAIS "Valeurs : ")
  152.   ) )
  153.   (throw 'debug 'continue)
  154. )
  155. (defun debug-continue () (throw 'debug 'quit))
  156.  
  157. (defun commands0 ()
  158.              (list
  159.                (DEUTSCH "
  160. Help = diese Liste
  161. Benutzen Sie die ⁿblichen Editierm÷glichkeiten."
  162.                 ENGLISH "
  163. Help = this list
  164. Use the usual editing capabilities."
  165.                 FRANCAIS "
  166. Help = cette liste
  167. ╔ditez de la faτon habituelle."
  168.                )
  169.                (cons "Help"   #'debug-help  )
  170. )            )
  171. (defun commands1 ()
  172.              (list
  173.                (DEUTSCH "
  174. Help   = dieses Menⁿ
  175. Abort  = Abbruch, Rⁿcksprung zur nΣchsth÷heren Eingabeschleife
  176. Unwind = Abbruch, Rⁿcksprung zur nΣchsth÷heren Eingabeschleife
  177. Mode-1 = alle Stack-Elemente inspizieren
  178. Mode-2 = alle Frames inspizieren
  179. Mode-3 = nur lexikalische Frames inspizieren
  180. Mode-4 = nur EVAL- und APPLY-Frames inspizieren (Default)
  181. Mode-5 = nur APPLY-Frames inspizieren
  182. Where  = diesen Frame inspizieren
  183. Up     = nΣchsth÷heren Frame inspizieren
  184. Top    = obersten Frame inspizieren
  185. Down   = nΣchstneueren Frame inspizieren
  186. Bottom = neuesten Frame inspizieren
  187. Backtrace-1 = alle Stack-Elemente auflisten
  188. Backtrace-2 = alle Frames auflisten
  189. Backtrace-3 = alle lexikalische Frames auflisten
  190. Backtrace-4 = alle EVAL- und APPLY-Frames auflisten
  191. Backtrace-5 = alle APPLY-Frames auflisten
  192. Backtrace   = Stack auflisten im aktuellen Mode
  193. Break+ = Breakpoint im EVAL-Frame setzen
  194. Break- = Breakpoint im EVAL-Frame l÷schen
  195. Redo   = Form im EVAL-Frame erneut auswerten
  196. Return = EVAL-Frame mit gegebenen Werten verlassen"
  197.                 ENGLISH "
  198. Help   = this command list
  199. Abort  = abort to the next recent input loop
  200. Unwind = abort to the next recent input loop
  201. Mode-1 = inspect all the stack elements
  202. Mode-2 = inspect all the frames
  203. Mode-3 = inspect only lexical frames
  204. Mode-4 = inspect only EVAL and APPLY frames (default)
  205. Mode-5 = inspect only APPLY frames
  206. Where  = inspect this frame
  207. Up     = go up one frame, inspect it
  208. Top    = go to top frame, inspect it
  209. Down   = go down one frame, inspect it
  210. Bottom = go to bottom (most recent) frame, inspect it
  211. Backtrace-1 = list all stack elements
  212. Backtrace-2 = list all frames
  213. Backtrace-3 = list all lexical frames
  214. Backtrace-4 = list all EVAL and APPLY frames
  215. Backtrace-5 = list all APPLY frames
  216. Backtrace   = list stack in current mode
  217. Break+ = set breakpoint in EVAL frame
  218. Break- = disable breakpoint in EVAL frame
  219. Redo   = re-evaluate form in EVAL frame
  220. Return = leave EVAL frame, prescribing the return values"
  221.                 FRANCAIS "
  222. Help   = ce menu-ci
  223. Abort  = arrΩt, retour au niveau supΘrieur
  224. Unwind = arrΩt, retour au niveau supΘrieur
  225. Mode-1 = examiner tous les ΘlΘments de la pile
  226. Mode-2 = examiner tous les ½frames╗
  227. Mode-3 = examiner uniquement les ½frames╗ lexicaux
  228. Mode-4 = examiner uniquement les ½frames╗ EVAL et APPLY (par dΘfaut)
  229. Mode-5 = examiner uniquement les ½frames╗ APPLY
  230. Where  = examiner ce ½frame╗
  231. Up     = examiner un ½frame╗ supΘrieur
  232. Top    = examiner le ½frame╗ le plus ΘlevΘ
  233. Down   = examiner un prochain ½frame╗ plus rΘcent (infΘrieur)
  234. Bottom = examiner le ½frame╗ le plus rΘcent (le plus bas)
  235. Backtrace-1 = montrer tous les ΘlΘments de la pile
  236. Backtrace-2 = montrer tous les ½frames╗
  237. Backtrace-3 = montrer tous les ½frames╗ lexicaux
  238. Backtrace-4 = montrer tous les ½frames╗ EVAL et APPLY
  239. Backtrace-5 = montrer tous les ½frames╗ APPLY
  240. Backtrace   = montrer la pile en mode actuel
  241. Break+ = placer un point d'interception dans le ½frame╗ EVAL
  242. Break- = enlever le point d'interception du ½frame╗ EVAL
  243. Redo   = rΘΘvaluer la forme dans le ½frame╗ EVAL
  244. Return = quitter le ½frame╗ EVAL avec certaines valeurs"
  245.                )
  246.                (cons "Help"   #'debug-help  )
  247.                (cons "?"      #'debug-help  )
  248.                (cons "Abort"  #'debug-unwind)
  249.                (cons "Unwind" #'debug-unwind)
  250.                (cons "Mode-1" #'debug-mode-1)
  251.                (cons "Mode-2" #'debug-mode-2)
  252.                (cons "Mode-3" #'debug-mode-3)
  253.                (cons "Mode-4" #'debug-mode-4)
  254.                (cons "Mode-5" #'debug-mode-5)
  255.                (cons "Where"  #'debug-where )
  256.                (cons "Up"     #'debug-up    )
  257.                (cons "Top"    #'debug-top   )
  258.                (cons "Down"   #'debug-down  )
  259.                (cons "Bottom" #'debug-bottom)
  260.                (cons "Backtrace-1" #'debug-backtrace-1)
  261.                (cons "Backtrace-2" #'debug-backtrace-2)
  262.                (cons "Backtrace-3" #'debug-backtrace-3)
  263.                (cons "Backtrace-4" #'debug-backtrace-4)
  264.                (cons "Backtrace-5" #'debug-backtrace-5)
  265.                (cons "Backtrace"   #'debug-backtrace  )
  266. )            )
  267. (defun commands2 ()
  268.              (list
  269.                (cons "Break+" #'debug-trap-on )
  270.                (cons "Break-" #'debug-trap-off)
  271.                (cons "Redo"   #'debug-redo  )
  272.                (cons "Return" #'debug-return)
  273. )            )
  274. (defun commands3 ()
  275.              (list
  276.                (DEUTSCH "
  277. Continue = Rest weiter abarbeiten"
  278.                 ENGLISH "
  279. Continue = continue evaluation"
  280.                 FRANCAIS "
  281. Continue = continuer l'Θvaluation"
  282.                )
  283.                (cons "Continue" #'debug-continue)
  284. )            )
  285.  
  286. ;; um Help-Kommando erweiterte Hauptschleife.
  287. (defun main-loop ()
  288.   (setq *break-count* 0)
  289.   (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausfⁿhren:
  290.     #'(lambda ()
  291.         (catch 'debug ; die (throw 'debug ...) abfangen
  292.           (if ; Eingabezeile verlangen
  293.               (read-eval-print (string-concat (prompt-string1) (prompt-string2) (prompt-string3))
  294.                                (copy-list (commands0))
  295.               )
  296.             ; T -> #<EOF>
  297.             (exit)
  298.             ; NIL -> Form bereits ausgewertet und ausgegeben
  299. ) )   ) ) )
  300. (setq *driver* #'main-loop)
  301.  
  302. ;; komfortable Break-Schleife. (LΣuft nur in compiliertem Zustand!)
  303. (defun break-loop (continuable &optional (condition nil) (print-it nil)
  304.                    &aux (may-continue
  305.                           (or continuable
  306.                               (and condition (find-restart 'continue condition))
  307.                         ) )
  308.                         (interactive-p (interactive-stream-p *debug-io*))
  309.                         (commandsr '())
  310.                   )
  311.   (when (and print-it (typep condition (clos:find-class 'condition)))
  312.     (symbol-stream '*error-output* :output)
  313.     ; Ein Zeichen auf *error-output* ausgeben, mit Abfangen von Endlosrekursion:
  314.     (let ((*recurse-count-error-output* (1+ *recurse-count-error-output*)))
  315.       (when (> *recurse-count-error-output* 3)
  316.         (setq *recurse-count-error-output* 0)
  317.         (close *error-output*) (symbol-stream '*error-output* :output)
  318.       )
  319.       (terpri *error-output*)
  320.     )
  321.     (if may-continue
  322.       (progn (write-string "** - Continuable Error" *error-output*) (terpri *error-output*))
  323.       (write-string "*** - " *error-output*)
  324.     )
  325.     ;; Output the error message, but don't trap into recursive errors.
  326.     (let ((*recursive-error-count* (1+ *recursive-error-count*)))
  327.       (if (> *recursive-error-count* 3)
  328.         (progn
  329.           (setq *recursive-error-count* 0)
  330.           (write-string (DEUTSCH "Unausgebbare Fehlermeldung"
  331.                          ENGLISH "Unprintable error message"
  332.                          FRANCAIS "Message inimprimable")
  333.                         *error-output*
  334.         ) )
  335.         (sys::print-condition condition *error-output*)
  336.     ) )
  337.     (symbol-stream '*debug-io* :io)
  338.     (when may-continue
  339.       (if continuable
  340.         (when interactive-p
  341.           (terpri *debug-io*)
  342.           (write-string (DEUTSCH "Sie k÷nnen (mit Continue) fortfahren."
  343.                          ENGLISH "You can continue (by typing 'continue')."
  344.                          FRANCAIS "Vous pouvez continuer (tapez ½continue╗ pour cela).")
  345.                         *debug-io*
  346.           )
  347.         )
  348.         (progn
  349.           (terpri *debug-io*)
  350.           (when interactive-p
  351.             (write-string (DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  352.                            ENGLISH "If you continue (by typing 'continue'): "
  353.                            FRANCAIS "Si vous continuez (en tapant ½continue╗): ")
  354.                           *debug-io*
  355.             )
  356.           )
  357.           (princ may-continue *debug-io*)
  358.   ) ) ) )
  359.   (when condition
  360.     (let ((restarts (remove may-continue (compute-restarts condition))))
  361.       (when restarts
  362.         (when interactive-p
  363.           (terpri *debug-io*)
  364.           (write-string (if may-continue
  365.                           (DEUTSCH "Weitere m÷gliche Optionen:"
  366.                            ENGLISH "The following restarts are available too:"
  367.                            FRANCAIS "D'autres rentrΘes possibles:")
  368.                           (DEUTSCH "M÷gliche Optionen:"
  369.                            ENGLISH "The following restarts are available:"
  370.                            FRANCAIS "RentrΘes possibles:")
  371.                         )
  372.                         *debug-io*
  373.         ) )
  374.         (let ((counter 0))
  375.           (dolist (restart restarts)
  376.             (let* ((command (string-concat "R" (sys::decimal-string (incf counter))))
  377.                    (helpstring (string-concat "
  378. " command " = " (princ-to-string restart))))
  379.               ; Restart-M÷glichkeit ausgeben:
  380.               (when interactive-p
  381.                 (write-string helpstring *debug-io*)
  382.               )
  383.               (push helpstring commandsr)
  384.               ; und in die Liste commandsr aufnehmen:
  385.               (push (cons command
  386.                           (let ((restart restart))
  387.                             #'(lambda () (invoke-restart-interactively restart))
  388.                     )     )
  389.                     commandsr
  390.           ) ) )
  391.           (setq commandsr (nreverse commandsr))
  392.   ) ) ) )
  393.   (tagbody
  394.     (let* ((*break-count* (1+ *break-count*))
  395.            (stream (make-synonym-stream '*debug-io*))
  396.            (*standard-input* stream)
  397.            (*standard-output* stream)
  398.            (prompt (with-output-to-string (s)
  399.                       (write-string (prompt-string1) s)
  400.                       (write *break-count* :stream s)
  401.                       (write-string ". Break" s)
  402.                       (write-string (prompt-string2) s)
  403.                       (write-string (prompt-string3) s)
  404.            )       )
  405.            (*frame-limit1* (frame-limit1 13))
  406.            (*frame-limit2* (frame-limit2))
  407.            (*debug-mode* 4)
  408.            (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  409.           )
  410.       (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausfⁿhren:
  411.         #'(lambda ()
  412.             (case
  413.                 (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  414.                   (same-env-as *debug-frame* ; bei *debug-frame* gⁿltiges Environment aufbauen
  415.                     #'(lambda ()
  416.                         (if ; Eingabezeile verlangen
  417.                             (read-eval-print prompt
  418.                               (nconc (copy-list (commands1))
  419.                                      (when (eval-frame-p *debug-frame*) (copy-list (commands2)))
  420.                                      (when may-continue (copy-list (commands3)))
  421.                                      commandsr
  422.                             ) )
  423.                           ; T -> #<EOF>
  424.                           (throw 'debug (if may-continue 'quit 'unwind))
  425.                           ; NIL -> Form bereits ausgewertet und ausgegeben
  426.                           #|(throw 'debug 'continue)|#
  427.                 ) )   ) )
  428.               (unwind (go unwind))
  429.               (quit ; nur erreicht, falls may-continue
  430.                 (if continuable
  431.                   (go quit)
  432.                   (invoke-restart-interactively may-continue)
  433.               ) )
  434.               (t ) ; alles andere, insbesondere continue
  435.     ) )   ) )
  436.     unwind (unwind-to-driver)
  437.     quit
  438. ) )
  439. (setq *break-driver* #'break-loop)
  440.  
  441. ;-------------------------------------------------------------------------------
  442. ;;        komfortabler Stepper. (LΣuft nur in compiliertem Zustand!)
  443.  
  444. (defvar *step-level* 0) ; momentane Step-Tiefe
  445. (defvar *step-quit* most-positive-fixnum) ; kritische Step-Tiefe:
  446.   ; sobald diese unterschritten wird, wacht der Stepper wieder auf.
  447. (defvar *step-watch* nil) ; Abbruchbedingung
  448.  
  449. ; (STEP form), CLTL S. 441
  450. (defmacro step (form)
  451.   `(let* ((*step-level* 0)
  452.           (*step-quit* most-positive-fixnum)
  453.           (*step-watch* nil)
  454.           (*evalhook* #'step-hook-fn))
  455.      ,form
  456.    )
  457. )
  458.  
  459. (defun commands4 ()
  460.              (list
  461.                (DEUTSCH "
  462. Step     = Step into form: diese Form im Einzelschrittmodus ausfⁿhren
  463. Next     = Step over form: diese Form auf einmal ausfⁿhren
  464. Over     = Step over this level: bis zum Aufrufer auf einmal ausfⁿhren
  465. Continue = Einzelschrittmodus abschalten, Rest ausfⁿhren
  466. Step-until, Next-until, Over-until, Continue-until:
  467.            dito, jedoch mit Angabe einer Abbruchbedingung"
  468.                 ENGLISH "
  469. Step     = step into form: evaluate this form in single step mode
  470. Next     = step over form: evaluate this form at once
  471. Over     = step over this level: evaluate at once up to the next return
  472. Continue = switch off single step mode, continue evaluation
  473. Step-until, Next-until, Over-until, Continue-until:
  474.            same as above, specify a condition when to stop"
  475.                 FRANCAIS "
  476. Step     = step into form: Θvaluer cette forme petit α petit
  477. Next     = step over form: Θvaluer cette forme en bloc
  478. Over     = step over this level: Θvaluer tout le reste jusqu'au prochain retour
  479. Continue = continue: Θvaluer tout le reste en bloc
  480. Step-until, Next-until, Over-until, Continue-until:
  481.            de mΩme, avec spΘcification d'une condition d'arrΩt"
  482.                )
  483.                (cons "Step"     #'(lambda () (throw 'stepper 'into)))
  484.                (cons "Next"     #'(lambda () (throw 'stepper 'over)))
  485.                (cons "Over"     #'(lambda () (throw 'stepper 'over-this-level)))
  486.                (cons "Continue" #'(lambda () (throw 'stepper 'continue)))
  487.                (cons "Step-until"     #'(lambda () (throw 'stepper (values 'into t))))
  488.                (cons "Next-until"     #'(lambda () (throw 'stepper (values 'over t))))
  489.                (cons "Over-until"     #'(lambda () (throw 'stepper (values 'over-this-level t))))
  490.                (cons "Continue-until" #'(lambda () (throw 'stepper (values 'continue t))))
  491. )            )
  492.  
  493. (defun step-values (values)
  494.   (let ((*standard-output* *debug-io*))
  495.     (terpri #|*debug-io*|#)
  496.     (write-string (DEUTSCH "Step "
  497.                    ENGLISH "step "
  498.                    FRANCAIS "Step ")
  499.                   #|*debug-io*|#
  500.     )
  501.     (write *step-level* #|:stream *debug-io*|#)
  502.     (write-string " ==> " #|*debug-io*|#)
  503.     (case (length values)
  504.       (0 (write-string (DEUTSCH "Keine Werte"
  505.                         ENGLISH "no values"
  506.                         FRANCAIS "Aucune valeur")
  507.                        #|*debug-io*|#
  508.       )  )
  509.       (1 (write-string (DEUTSCH "Wert: "
  510.                         ENGLISH "value: "
  511.                         FRANCAIS "Valeur : ")
  512.                        #|*debug-io*|#
  513.          )
  514.          (write (car values) #|:stream *debug-io*|#)
  515.       )
  516.       (t (write (length values) #|:stream *debug-io*|#)
  517.          (write-string (DEUTSCH " Werte: "
  518.                         ENGLISH " values: "
  519.                         FRANCAIS " Valeurs : ")
  520.                        #|*debug-io*|#
  521.          )
  522.          (do ((L values))
  523.              ((endp L))
  524.            (write (pop L) #|:stream *debug-io*|#)
  525.            (unless (endp L) (write-string ", " #|*debug-io*|#))
  526.       )  )
  527.   ) )
  528.   (values-list values)
  529. )
  530.  
  531. (defun step-hook-fn (form &optional (env *toplevel-environment*))
  532.   (let ((*step-level* (1+ *step-level*)))
  533.     (when (>= *step-level* *step-quit*) ; Solange *step-level* >= *step-quit*
  534.       (if (and *step-watch* (funcall *step-watch*)) ; und kein Breakpoint,
  535.         (setq *step-quit* most-positive-fixnum)
  536.         (return-from step-hook-fn ; ist der Stepper passiv
  537.           (evalhook form nil nil env) ; (d.h. er evaluiert die Form einfach)
  538.     ) ) )
  539.     (tagbody
  540.       (let* ((stream (make-synonym-stream '*debug-io*))
  541.              (*standard-input* stream)
  542.              (*standard-output* stream)
  543.              (prompt (with-output-to-string (s)
  544.                        (write-string (prompt-string1) s)
  545.                        (write-string "Step " s)
  546.                        (write *step-level* :stream s)
  547.                        (write-string (prompt-string2) s)
  548.                        (write-string (prompt-string3) s)
  549.              )       )
  550.              (*frame-limit1* (frame-limit1 11))
  551.              (*frame-limit2* (frame-limit2))
  552.              (*debug-mode* 4)
  553.              (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  554.             )
  555.         (fresh-line #|*debug-io*|#)
  556.         (write-string (DEUTSCH "Step "
  557.                        ENGLISH "step "
  558.                        FRANCAIS "Step ")
  559.                       #|*debug-io*|#
  560.         )
  561.         (write *step-level* #|:stream *debug-io*|#)
  562.         (write-string " --> " #|*debug-io*|#)
  563.         (write form #|:stream *debug-io*|# :length 4 :level 3)
  564.         (loop
  565.           (multiple-value-bind (what watchp)
  566.             (catch 'stepper ; die (throw 'stepper ...) abfangen und analysieren
  567.               (driver ; Driver-Frame aufbauen und folgende Funktion endlos ausfⁿhren:
  568.                 #'(lambda ()
  569.                     (case
  570.                         (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  571.                           (same-env-as *debug-frame* ; bei *debug-frame* gⁿltiges Environment aufbauen
  572.                             #'(lambda ()
  573.                                 (if ; Eingabezeile verlangen
  574.                                     (read-eval-print prompt
  575.                                       (nconc (copy-list (commands1))
  576.                                              (when (eval-frame-p *debug-frame*) (copy-list (commands2)))
  577.                                              (copy-list (commands4))
  578.                                     ) )
  579.                                   ; T -> #<EOF>
  580.                                   (go continue)
  581.                                   ; NIL -> Form bereits ausgewertet und ausgegeben
  582.                                   #|(throw 'debug 'continue)|#
  583.                         ) )   ) )
  584.                       (unwind (go unwind))
  585.                       (t ) ; alles andere, insbesondere continue
  586.             ) )   ) )
  587.             (when watchp
  588.               (let ((form (read-form (DEUTSCH "Abbruchbedingung: "
  589.                                       ENGLISH "condition when to stop: "
  590.                                       FRANCAIS "condition d'arrΩt : ")
  591.                    ))     )
  592.                 (setq *step-watch* ; Funktion, die 'form' bei *debug-frame* auswertet
  593.                   (eval-at *debug-frame* `(function (lambda () ,form)))
  594.             ) ) )
  595.             (case what
  596.               (into (go into))
  597.               (over (go over))
  598.               (over-this-level (go over-this-level))
  599.               (continue (go continue))
  600.             )
  601.       ) ) )
  602.       unwind
  603.         (unwind-to-driver)
  604.       into
  605.         (return-from step-hook-fn
  606.           (step-values
  607.             (multiple-value-list (evalhook form #'step-hook-fn nil env))
  608.         ) )
  609.       over-this-level
  610.         (setq *step-quit* *step-level*) ; Stepper in Schlafzustand schalten
  611.       over
  612.         (return-from step-hook-fn
  613.           (step-values
  614.             (multiple-value-list (evalhook form nil nil env))
  615.         ) )
  616.       continue
  617.         (setq *step-quit* 0)
  618.         (go over)
  619. ) ) )
  620.  
  621. ;-------------------------------------------------------------------------------
  622. ;;                                  Errors
  623.  
  624. ; *ERROR-HANDLER* sollte NIL oder eine Funktion sein, die ⁿbergeben bekommt:
  625. ; - NIL (bei ERROR) bzw. continue-format-string (bei CERROR),
  626. ; - error-format-string,
  627. ; - Argumente dazu,
  628. ; und die nur zurⁿckkehren sollte, falls das erstere /=NIL ist.
  629. (defvar *error-handler* nil)
  630.  
  631. ; (CERROR continue-format-string error-format-string {arg}*), CLTL S. 430
  632. (defun cerror (continue-format-string error-format-string &rest args)
  633.   (if *error-handler*
  634.     (apply *error-handler*
  635.            (or continue-format-string t) error-format-string args
  636.     )
  637.     (progn
  638.       (terpri *error-output*)
  639.       (write-string "** - Continuable Error" *error-output*)
  640.       (terpri *error-output*)
  641.       (apply #'format *error-output* error-format-string args)
  642.       (terpri *debug-io*)
  643.       (if (interactive-stream-p *debug-io*)
  644.         (progn
  645.           (write-string (DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  646.                          ENGLISH "If you continue (by typing 'continue'): "
  647.                          FRANCAIS "Si vous continuez (en tapant ½continue╗): ")
  648.                         *debug-io*
  649.           )
  650.           (apply #'format *debug-io* continue-format-string args)
  651.           (funcall *break-driver* t)
  652.         )
  653.         (apply #'format *debug-io* continue-format-string args)
  654.   ) ) )
  655.   nil
  656. )
  657.  
  658. (defvar *break-on-warnings* nil)
  659. ; (WARN format-string {arg}*), CLTL S. 432
  660. (defun warn (format-string &rest args)
  661.   (terpri *error-output*)
  662.   (write-string (DEUTSCH "WARNUNG:"
  663.                  ENGLISH "WARNING:"
  664.                  FRANCAIS "AVERTISSEMENT :")
  665.                 *error-output*
  666.   )
  667.   (terpri *error-output*)
  668.   (apply #'format *error-output* format-string args)
  669.   (when *break-on-warnings* (funcall *break-driver* t))
  670.   nil
  671. )
  672.  
  673. ; (BREAK [format-string {arg}*]), CLTL S. 432
  674. (defun break (&optional (format-string "*** - Break") &rest args)
  675.   (terpri *error-output*)
  676.   (apply #'format *error-output* format-string args)
  677.   (funcall *break-driver* t)
  678.   nil
  679. )
  680.  
  681. ; (SYSTEM::BATCHMODE-ERRORS {form}*) executes the forms, but handles errors
  682. ; just as a batch program should do: continuable errors are signalled as
  683. ; warnings, non-continuable errors cause Lisp to exit.
  684. (defmacro batchmode-errors (&body body)
  685.   `(LET ((*ERROR-HANDLER* #'BATCHMODE-ERROR-HANDLER))
  686.      (PROGN ,@body)
  687.    )
  688. )
  689. (defun batchmode-error-handler (continue errorstring &rest args)
  690.   (if continue
  691.     (warn "~A~%~A" (apply #'format nil errorstring args)
  692.                    (apply #'format nil continue args)
  693.     )
  694.     (progn
  695.       (terpri *error-output*)
  696.       (write-string "*** - " *error-output*)
  697.       (apply #'format *error-output* errorstring args)
  698.       (exit t) ; exit Lisp with error
  699. ) ) )
  700.  
  701. ;-------------------------------------------------------------------------------
  702. ;;                            Querying the user
  703.  
  704. ; (Y-OR-N-P [format-string {arg}*]), CLTL S. 407
  705. (defun y-or-n-p (&optional format-string &rest args)
  706.   (when format-string
  707.     (fresh-line *query-io*)
  708.     (apply #'format *query-io* format-string args)
  709.     (write-string (DEUTSCH " (j/n) "
  710.                    ENGLISH " (y/n) "
  711.                    FRANCAIS " (o/n) ")
  712.                   *query-io*
  713.   ) )
  714.   (loop
  715.     (let ((line (string-left-trim " " (read-line *query-io*))))
  716.       (when (plusp (length line))
  717.         (case (char-upcase (char line 0))
  718.           (#\N (return nil))
  719.           ((#\J #\Y #\O) (return t))
  720.     ) ) )
  721.     (terpri *query-io*)
  722.     (write-string (DEUTSCH "Bitte mit j oder n antworten: "
  723.                    ENGLISH "Please answer with y or n : "
  724.                    FRANCAIS "RΘpondez par o ou n : ")
  725.                   *query-io*
  726. ) ) )
  727.  
  728. ; (YES-OR-NO-P [format-string {arg}*]), CLTL S. 408
  729. (defun yes-or-no-p (&optional format-string &rest args)
  730.   (when format-string
  731.     (fresh-line *query-io*)
  732.     (apply #'format *query-io* format-string args)
  733.     (write-string (DEUTSCH " (ja/nein) "
  734.                    ENGLISH " (yes/no) "
  735.                    FRANCAIS " (oui/non) ")
  736.                   *query-io*
  737.   ) )
  738.   (loop
  739.     (clear-input *query-io*)
  740.     (let* ((line (string-trim " " (read-line *query-io*)))
  741.            (h (assoc line '(("ja" . t) ("nein" . nil)
  742.                             ("yes" . t) ("no" . nil)
  743.                             ("oui" . t) ("non" . nil)
  744.                            )
  745.                           :test #'string-equal
  746.           ))  )
  747.       (when h (return (cdr h)))
  748.     )
  749.     (terpri *query-io*)
  750.     (write-string (DEUTSCH "Bitte mit ja oder nein antworten: "
  751.                    ENGLISH "Please answer with yes or no : "
  752.                    FRANCAIS "RΘpondez par oui ou non : ")
  753.                   *query-io*
  754. ) ) )
  755.  
  756. (defvar *keyboard-input*)
  757. (defmacro with-keyboard (&body body)
  758.   `(SYS::EXEC-WITH-KEYBOARD (FUNCTION (LAMBDA () (PROGN ,@body))))
  759. )
  760. (defun exec-with-keyboard (fun)
  761.   #+(or DOS OS/2) ; *keyboard-input* existiert schon
  762.     (funcall fun)
  763.   #+(or UNIX ACORN-RISCOS)
  764.     (let ((mode nil))
  765.       (unwind-protect
  766.         (progn (setq mode (sys::terminal-raw *terminal-io* t)) (funcall fun))
  767.         (sys::terminal-raw *terminal-io* mode)
  768.     ) )
  769.   #+AMIGA
  770.     (let ((*keyboard-input* (screen::make-keyboard-stream *terminal-io*)))
  771.       (unwind-protect
  772.         (funcall fun)
  773.         (close *keyboard-input*)
  774.     ) )
  775. )
  776.  
  777.